home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / e_to_l / isamexpt / mybubble.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  6KB  |  228 lines
  1. unit MyBubble;
  2.  
  3. {$R-,W-,S-}
  4.  
  5. interface
  6.  
  7. uses
  8.   WinTypes, WinProcs, SysUtils, Messages, Classes, Controls,
  9.   Graphics, Forms, Dialogs, StdCtrls, ExtCtrls;
  10.  
  11. type
  12.   TBubble = class(THintWindow)
  13.   private
  14.     FDC, FCopyDC: HDC;
  15.     FCopyBitmap: HBitmap;
  16.     FOrigBrush1, FBrush1: HBrush;
  17.     FOrigBrush2, FBrush2: HBrush;
  18.     FRect: TRect;
  19.     FFlag: Boolean;
  20.     FTimerHandle: Word;
  21.     FTimerActive: Boolean;
  22.     procedure WMTimer(var Message: TWMTimer); message WM_TIMER;
  23.   public
  24.     Active: Boolean;
  25.     constructor Create(AOwner: TComponent); Override;
  26.     destructor Destroy; Override;
  27.     procedure ShowBubble(Rect: TRect; s1,s2: string);
  28.   end;
  29.  
  30.   Var
  31.   Bubble : TBubble;
  32.  
  33. Procedure ShowBubble(AParent: TForm; R: TRect; aTime: Integer;
  34.                      S1,S2: String);
  35.  
  36. Implementation
  37.  
  38. Uses UToolDll;
  39.  
  40. Const
  41. BubbleShadow : Boolean = True;
  42. var Zahl: Integer;
  43.  
  44. function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer;
  45.   Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean;
  46.  
  47. var
  48.   TempBitmap: HBitmap;
  49.  
  50. begin
  51.   Result := False;
  52.   CopyDC := 0;
  53.   CopyBitmap := 0;
  54.   if DC <> 0 then
  55.     begin
  56.       CopyDC := CreateCompatibleDC(DC);
  57.       if CopyDC <> 0 then
  58.         begin
  59.           CopyBitmap := CreateCompatibleBitmap(DC, Width, Height);
  60.           if CopyBitmap <> 0 then
  61.             begin
  62.               TempBitmap := CopyBitmap;
  63.               CopyBitmap := SelectObject(CopyDC, CopyBitmap);
  64.               Result := BitBlt(CopyDC, 0, 0, Width, Height, DC,
  65.                 Left, Top, Rop);
  66.               CopyBitmap := TempBitmap;
  67.             end;
  68.         end;
  69.     end;
  70. end;
  71.  
  72. function CopyBufToClip(DC: HDC; var CopyDC: HDC;
  73.   var CopyBitmap: HBitmap; Left, Top, Width, Height: Integer;
  74.   Rop: LongInt; DeleteObjects: Boolean): Boolean;
  75.  
  76. var
  77.   TempBitmap: HBitmap;
  78.  
  79. begin
  80.   Result := False;
  81.   if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then
  82.     begin
  83.       TempBitmap := CopyBitmap;
  84.       CopyBitmap := SelectObject(DC, CopyBitmap);
  85.       Result := BitBlt(DC, Left, Top, Width, Height, CopyDC,
  86.         0, 0, Rop);
  87.       CopyBitmap := TempBitmap;
  88.       if DeleteObjects then
  89.         begin
  90.           DeleteDC(CopyDC);
  91.           DeleteObject(CopyBitmap);
  92.         end;
  93.     end;
  94. end;
  95.  
  96. procedure TimerProc(Wnd: HWnd; Msg: Word; TimerID: Word;
  97.   SysTime: Longint); export;
  98. begin
  99.   inc(Zahl);
  100.   if Zahl > 2 then begin
  101.     if Bubble <> NIL then Bubble.Free;
  102.   end;
  103. end;
  104.  
  105. constructor TBubble.Create(AOwner: TComponent);
  106. begin
  107.   inherited Create(AOwner);
  108.   Zahl:= 0;
  109.   Active:= True;
  110.   FDC := CreateDC('DISPLAY', '', '', nil);
  111.   FOrigBrush2 := CreateSolidBrush(RGB(0, 0, 0));
  112.   SetBkMode(FDC, TRANSPARENT);
  113.   SetTextColor(FDC, RGB(0, 0, 0));
  114.   FFlag := False;
  115.   FTimerHandle := SetTimer(Handle, 1, Application.HintPause, NIL);
  116.   FTimerActive := FTimerHandle > 0;
  117. end;
  118.  
  119. procedure TBubble.WMTimer(var Message: TWMTimer);
  120. begin
  121.   inc(Zahl);
  122.   if Zahl > 0 then Active:= False;
  123. end;
  124.  
  125. destructor TBubble.Destroy;
  126. begin
  127.   if FTimerActive then
  128.   begin
  129.     KillTimer(0, FTimerHandle);
  130.     FTimerActive := False;
  131.   end;
  132.   if FFlag then
  133.     CopyBufToClip(FDC, FCopyDC, FCopyBitmap, FRect.Left,
  134.       FRect.Top, FRect.Right-FRect.Left, FRect.Bottom-FRect.Top,
  135.       SRCCOPY, True);
  136.   DeleteObject(FOrigBrush2);
  137.   DeleteDC(FDC);
  138.   inherited Destroy;end;
  139.  
  140. procedure TBubble.ShowBubble(Rect: TRect; S1,s2: string);
  141. var
  142.   Text: array[0..255] of Char;
  143.   TextExtent: LongInt;
  144.   TextWidth: Word;
  145.   s1Len,S2Len : Word;
  146.   WinWidth: Integer;
  147.   Factor: Integer;
  148.   Difference: Integer;
  149.  
  150. begin
  151.   BubbleShadow := True;
  152.   FOrigBrush1 := CreateSolidBrush(Application.HintColor);
  153.   FBrush1 := SelectObject(FDC, FOrigBrush1);
  154.   FRect := Rect;
  155.   TextExtent := GetTextExtent(FDC, StrPCopy(Text, s1), Length(S1));
  156.   TextWidth := TextExtent mod 65536;
  157.   FRect.Right := FRect.Left+TextWidth+40;
  158.   FRect.Left := FRect.Left-(TextWidth div 2);
  159.   FRect.Right := FRect.Right-(TextWidth div 2);
  160.   Factor := 80+(TextWidth div 6);
  161.   FRect.Bottom := FRect.Top+Factor;
  162.   if FRect.Left < 0 then
  163.   begin
  164.     Difference := -FRect.Left;
  165.     FRect.Left := FRect.Left+Difference;
  166.     FRect.Right := FRect.Right+Difference;
  167.   end;
  168.   if FRect.Top < 0 then
  169.   begin
  170.     Difference := -FRect.Top;
  171.     FRect.Top := FRect.Top+Difference;
  172.     FRect.Bottom := FRect.Bottom+Difference;
  173.   end;
  174.   if FRect.Right > Screen.Width then
  175.   begin
  176.     Difference := FRect.Right-Screen.Width;
  177.     FRect.Left := FRect.Left-Difference;
  178.     FRect.Right := FRect.Right-Difference;
  179.   end;
  180.   if FRect.Bottom > Screen.Height then
  181.   begin
  182.     Difference := FRect.Bottom-Screen.Height;
  183.     FRect.Top := FRect.Top-Difference;
  184.     FRect.Bottom := FRect.Bottom-Difference;
  185.   end;
  186.   FFlag := CopyClipToBuf(FDC, FRect.Left, FRect.Top,
  187.     FRect.Right-FRect.Left, FRect.Bottom-FRect.Top,
  188.     SRCCOPY, FCopyDC, FCopyBitmap);
  189.   if BubbleShadow then
  190.   begin
  191.     FBrush2 := SelectObject(FDC, FOrigBrush2);
  192.     Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right, FRect.Bottom);
  193.   end;
  194.   FBrush1 := SelectObject(FDC, FOrigBrush1);
  195.   if BubbleShadow then
  196.     Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right-4, FRect.Bottom-4)
  197.   else
  198.     Ellipse(FDC, FRect.Left, FRect.Top+20, FRect.Right, FRect.Bottom);
  199.     Ellipse(FDC, FRect.Left+((FRect.Right-FRect.Left) div 2)-7,
  200.     FRect.Top+8, FRect.Left+((FRect.Right-FRect.Left) div 2)+7,
  201.     FRect.Top+18);
  202.     Ellipse(FDC, FRect.Left+((FRect.Right-FRect.Left) div 2),
  203.     FRect.Top, FRect.Left+((FRect.Right-FRect.Left) div 2)+9,
  204.     FRect.Top+6);
  205.     TextOut(FDC, FRect.Left+15, FRect.Top+(Factor div 2)-5, StrPCopy(Text,S1),
  206.     Length(S1));
  207.     TextOut(FDC, FRect.Left+15, FRect.Top+7+(Factor div 2), StrPCopy(Text,S2),
  208.     Length(S2));
  209.     DeleteObject(FOrigBrush1);
  210.     Visible:= True;
  211.   end;
  212.  
  213. Procedure ShowBubble(AParent: TForm; R: TRect; aTime: Integer;
  214.                      S1,S2: String);
  215. begin
  216.   Bubble := TBubble.Create(AParent);
  217.   Try
  218.     Bubble.ShowBubble(R,S1,S2);
  219.   Finally
  220.     Repeat
  221.       Application.ProcessMessages;
  222.     Until Bubble.Active = False;
  223.     Bubble.Free;
  224.   end;
  225. end;
  226.  
  227. end.
  228.